Celestin Apprentice 5

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / CGIshell 1.3.2 / shell / shell.4th < prev next >

Wrap

Text File | 1996-04-23 | 25.2 KB | 758 lines | [TEXT/ALFA]

\ \ \ PF Forms Handler Shell -- version 1.3.2 \ \ \ (c) Ronald T. Kneusel, 1995, 1996 \ (rkneusel@post.its.mcw.edu) \ \ This code may be used and distributed freely provided the copyright \ notice remains intact and my name is mentioned in the documentation. \ \ Last mod: 22-Apr-96 \ ========================================================================= \ \ This file contains all the code in the following files: \ \ server.4th - web server interface \ field.4th - new field definition words \ template.4th - template words (new version) \ \ A minimal CGI needs the server.4th file at least. The others implement more \ advanced field processing and template file handling. They must be loaded \ in the order listed. \ \ Unless space is a consideration, begin your CGI code with this line: \ \ --> shell.4th \ \ to load all segments in the proper order. The directory OLD contains the \ version 1.2 code without the new field definition words. Use it only if \ you have older CGIs to maintain. \ \ \ \ @Field ( addr1 addr2 new|append -- ) \ \ Get the post data string for the field whose address is \ on the stack. Place the data into the string at addr2. @Field \ will convert characters as necessary. \ \ @Addr ( addr new|append -- ) \ \ Put the client's IP address in the string at addr \ \ @Direct ( addr new|append -- ) \ \ Put the direct argument in the string at addr \ \ @Browser ( addr new|append -- ) \ \ Put the browser type in the string at addr \ \ REPLY ( addr -- ) \ \ Send the string back to WebSTAR. Use only within ae: ... ;ae \ ( yet more disk I/O words by C. Heilman ) \ create space for the fcb and a word to access it variable FCB 78 allot ( our File's Control Block ) : +FCB ( offset -- addr ) fcb + ; ( offset into fcb ) \ setup for a (register based) file manager toolbox call : FTRAP ( -- ) fcb >abs ,$ 205E ; ( movea.l [ps]+,a0 ) : CLOSE ( -- ) ftrap ,$ A001 ftrap ,$ A013 ; ( _Close & _FlushBuffer ) : ?DERROR ( -- ) \ report error if result is not zero 16 +fcb @ ?dup IF ." DiskError" . close abort THEN ; \ open a file with the address of a string of the pathname on the stack : OPEN ( addr -- ) \ addr is a Forth style string - str[255] fcb 80 0 fill \ clear the fcb for a new file >abs 18 +fcb 2! \ set name of the file to string ftrap ,$ A000 ?derror ; \ _Open the file in the fcb \ create a file : NEWFILE ( name.addr -- ) fcb 80 0 fill \ clear the fcb for a new file >abs 18 +fcb 2! \ set name of the file to string ftrap ,$ A008 ?derror ( _Create ) ,s TEXT 32 +fcb 2! \ TEXT type ftrap ,$ A00D ?derror ; ( _SetFileInfo ) \ return the filesize !!! MUST BE <32K !!! : @SIZE ( -- bytes ) ftrap ,$ A011 30 +fcb @ ; ( _GetEOF ) \ set some fcb parameters : !SIZE ( bytes -- ) 38 +fcb ! ; \ set bytes-to-read/write : !BUFF ( addr -- ) >abs 32 +fcb 2! ; \ set read/write buffer pointer \ read/write with buffer addr and bytes to read/write on the stack : READ ( addr count -- ) !size !buff ftrap ,$ A002 ?derror ; ( _Read ) : WRITE ( addr count -- ) !size !buff ftrap ,$ A003 ?derror ; ( _Write ) \ read/write file a byte at a time to/from the stack : GETCHR ( -- c ) here 1 read here c@ ; : PUTCHR ( c -- ) here c! here 1 write ; \ read until character (c) is encountered : CREAD ( addr c -- bytes_read ) 44 +fcb c! 128 45 +fcb c! \ setup ioPosMode @SIZE read 42 +fcb @ ; \ put lowbyte of ioActCount on stack \ A defining word for strings : $[ \ compiling: ( -- ) enclose a ] terminated string CREATE 93 word here c@ 1+ dup 2 mod + allot DOES> ; \ runtime action: ( -- addr ) \ <<-- no count! ( end I/O words ) ( *************************** String Functions **************************** ) ( Strings 10/15/95 23:30:19 ) \ \ These words deal with 0 terminated strings. \ \ The names maintain compatability with the word-set in \ _Library of Forth Routines and Utilities_ by James D. Terry \ (c) 1986 Shadow Lawn Press ISBN 0-452-25841-3 \ \ In comments, string is the starting address of a zero terminated string, \ and len is the length not including the zero. String[255] is a length \ byte preceded string, with a max length of 255 bytes. \ \ String format: \ string address is first byte ->This is a string.0<- Ends with a zero \ *** Most of these routines written by C. Heilman *** \ Length and $clear get used a lot - do them in ml. : LENGTH ( string -- len ) \ length of the string at addr ( was: dup >r BEGIN dup c@ WHILE 1+ REPEAT r> - ; ) ,$ 3016 \ move (ps),d0 ,$ 4a33 ,$ 0000 \ @0: tst.b 0(bp,d0.w) ,$ 6706 \ beq.s @1 ,$ 0640 ,$ 0001 \ addi #1,d0 ,$ 60f4 \ bra.s @0 ,$ 9056 \ @1: sub (ps),d0 ,$ 3c80 ; \ move d0,(ps) : $CLEAR ( string -- ) \ erase a string ( equivalent to: 0 swap c! ; ) ,$ 301E ,$ 4233 ,$ 0000 ; \ move (ps)+,d0 clr.b 0(bp,d0.w) \ The next 4 words are directly from Ron's CGI Framework. \ Convert between null terminated and length byte preceeded type strings. : >NULL ( string[255] -- ) \ convert a string[255] into a string dup c@ 2dup + >r swap dup 1+ swap rot cmove r> $clear ; : >COUNT ( string -- ) \ convert a string into a string[255] dup length >r dup dup 1+ r cmove r> swap c! ; \ Terminal I/O. : 0TYPE ( string -- ) \ type null terminated string dup length dup IF type ELSE 2drop THEN ; : ACCEPT ( string len -- ) \ like expect but stores zero at end of line 2dup 1+ 0 fill >r dup r> expect dup length 1- + $clear ; ( bug fixed) \ Test a string's content. : $= ( string1 string2 -- f ) \ true if string2,len2 = string1,len1 dup length 1+ -1 swap 2swap rot 0 DO \ set flag to true over r + c@ over r + c@ = \ check each byte 0= IF rot 1+ rot rot leave THEN \ change flag to false LOOP 2drop ; \ Manipulate strings. : $COPY ( source.string dest.string -- ) \ copy source to dest over length 1+ cmove ; : $+ ( source.string dest.string -- ) \ append source to the end of dest dup length + $copy ; : $LEFT ( string len -- ) \ clip string to len chars over length min + $clear ; : $RIGHT ( string len -- ) \ clip string to rightmost len characters over length over - 0> IF over length over - rot dup rot + swap rot 1+ cmove ELSE 2drop THEN ; : $MID ( string start len -- ) \ clip string to len section at start rot rot over length swap - 1+ >r dup r> $right swap $left ; : $UPPER ( string -- ) dup >count dup upper dup >null drop ; \ uppercase : $CHAR ( character string -- ) dup length + dup >r c! 0 r> 1+ c! ; \ Find and replace with strings. variable POS ( local variable ) : $FIND ( string1 string2 -- pos ) \ find string2 in string1; 0 if unfound 0 pos ! over length over length - 2+ 1 DO over here $copy here over length r swap $mid here over $= IF r pos ! leave THEN LOOP 2drop pos @ ; : $REPLACE ( dest.string1 find.string2 replace.string3 -- ) rot >r swap r over $find ?dup IF \ IF string2 is found in string1 r here $copy \ THEN replace string2 with string3 r over 1- $left \ modify string1 rot r $+ swap length + \ !!! IMPORTANT !!! here length swap - 1+ \ DOES NOT CHECK FOR OVERWRITE here swap $right \ String1 MUST accomodate any here r> $+ \ additional bytes from string3 ELSE 2drop r> drop THEN ; \ Create and assign strings of several varieties. : $CONSTANT \ compiling: ( -- ) name a string terminated with '}' CREATE 125 word here c@ 1+ dup 2 mod + allot 0 [compile] , DOES> count drop ; \ runtime action: ( -- string ) \ This uses a curley brace because they aren't used much on web pages. \ eg: $constant ESERROR Empty stack!} : $VARIABLE CREATE 1+ allot ; \ compiling: ( len -- ) name an empty string \ eg: 80 $variable INPUTLINE inputline ${ Hi there!} : $ARRAY \ create named string arrays - name from input stream CREATE dup , * allot \ compiling: ( number_of_.strings len -- ) DOES> dup @ rot * + 2+ ; \ runtime: ( string_number -- string ) \ eg: 15 64 $array ERRORMESSAGES \ 0 errorMessages ${ Error!} \ NOTE: Constants and variables are identical except that constants \ have no room to grow, but variables _may_ have extra memory \ allotted to them to grow into. Also constants are assigned \ when they are created, while variables (and arrays, which are \ lists of variables) must be assigned seperately (see below). : ${ ( string -- ) \ assign text to a string from the input stream. 125 word here >null here swap $copy ; \ eg: inputLine ${ Something to say!} *** NO OVERWRITE CHECK *** : MESSAGE[ \ compiling: ( -- ) enclose subsequent ']'ed string CREATE 93 word here c@ 1+ dup 2 mod + allot 0 [compile] , DOES> count drop ; \ runtime action: ( -- addr ) : STRING>> \ compiling: ( n -- ) number of bytes in the string CREATE allot ; : <> = 0= ; macro : newstr ( addr -- ) \ zero a string 0 swap c! ; : strcpy ( str1 str2 -- ) \ copy string 1 to string 2 dup length + >r \ automatically append BEGIN dup c@ 0 <> WHILE dup c@ r c! r> 1+ >r 1+ REPEAT 0 r> c! ; : strncpy ( str1 str2 -- ) \ copy as above, clear str2 first dup newstr strcpy ; : 0type ( addr -- ) \ type null terminated string dup length dup 0 <> IF type ELSE 2drop THEN ; : >null ( addr -- ) \ convert a counted string into a null terminated string dup c@ 2dup + >r swap dup 1+ swap rot cmove 0 r> c! ; : >count ( addr -- ) \ convert a null terminated string into a counted string dup length >r dup dup 1+ r cmove r> swap c! ; : accept ( addr len -- ) \ like expect but no blank at end of line swap dup >r swap expect 0 r r> length 1- c! ; ( **************** Apple Event and reply string handler ******************* ) \ This code courtesy of C. Heilman, slight mods RTK 2variable DDATA 4 allot MESSAGE[ SERROR Empty stack!] ( get AEDesc handle from an Apple Event ) : ?DESC ( d.key d.type -- desc.handle desc.type -1 or 0 ) 0 >r ( room for error ) 202 +md 2@ 2>r ( the AppleEvent handle ) 2swap 2>r 2>r ( keyword and type ) here a>r ( receiving address ) ,$ 303C ,$ 812 ,$ A816 ( AEGetParamDesc: move #$812,d0 _Pack8 ) r> 0= IF ( if there is no error ) here 4 + 2@ here 2@ -1 ( get data & leave true ) ELSE 0 THEN ; ( or else leave false ) : -DESC ( addr.where.desc.is.stored -- error ) ( remove desc rec. ) 0 >r a>r ( push room and descriptor ) ,$ 303C ,$ 0204 ,$ A816 ( AEDisposeDesc: move #$0204,d0 _Pack8 ) r> ; 2variable DSIZE \ this double variable holds the size of a string in dbuff variable DBUFF 4094 allot \ this block is filled with a text string ( get AE data from an Apple Event ) : ?DATA ( d.key -- addr -1 or 0 ) 0 >r \ make room on stack for error 202 +md 2@ 2>r \ push theAppleEvent address 2>r ,s TEXT 2>r \ push keyword (from pstack) and desired type (TEXT) here a>r \ push an address to hold the actual type dbuff a>r \ push the data receiving address 4096 s>d 2>r \ max number of bytes to read dsize a>r \ push a variable to hold the actual size ,$ 303C ,$ 0E11 ,$ A816 \ AEGetParamPtr: move #$812,d0 _Pack8 r> 0= IF \ if there is no error \ dbuff dsize 2@ drop -1 \ put address, count and true on pstack 0 dbuff dsize 2@ drop + c! dbuff -1 \ make null terminated ELSE 0 THEN ; \ else false \ Reply to an Apple Event with a string : REPLY ( addr -- ) \ **** USE INSIDE OF A HANDLER ONLY **** dup length \ how long is it? 0 >r \ put room for error on rstack 198 +md 2@ 2>r \ put the ReplyEvent handle on rstack ,s ---- 2>r ,s TEXT 2>r \ put keyword and type on rstack swap a>r 0 2>r \ put addr & count on rs from pstack ,$ 303C ,$ 0A0F ,$ A816 \ AEPutParamPtr: move #$A0F,d0 _Pack8 r> drop ; \ ignore any error ( ******************* Words to get field data *********************** ) 0 constant NEW \ start a new string -1 constant APPEND \ append at end of existing string variable theAddr \ holds the address of the string : zeroStr ( -- ) \ zero the string in theAddr 0 theAddr @ c! ; : >append ( c -- ) \ put a character on the end of theAddr theAddr @ length theAddr @ + dup >r c! \ character 0 r> 1+ c! ; \ null : count>str ( addr len -- ) \ copy characters into the string >r dup r> + swap DO r c@ >append LOOP ; variable <str> \ address of target string : h>d ( c -- d ) \ hex digit to decimal, no error checking dup 64 > IF 55 - ELSE 48 - THEN ; : hex>char ( addr -- ) \ convert a %xx sequence into a character 1+ dup c@ swap 1+ c@ h>d swap h>d 16 * + dup 32 < IF 13 = IF 13 <str> @ $CHAR THEN \ return character ELSE <str> @ $CHAR \ anything >= space THEN ; : $copy+ ( s1 len s2 -- ) \ copy s1 to s2 changing %nn codes to characters <str> ! \ keep address of target string swap dup rot + swap DO r c@ dup 43 = IF drop 32 <str> @ $CHAR 1 ELSE \ '+' to space dup 37 = IF drop r hex>char 3 ELSE \ %xx <str> @ $CHAR 1 THEN THEN \ alphanumeric character +LOOP ; create ~cr 3 allot 13 ~cr c! 10 ~cr 1+ c! 0 ~cr 2+ c! : +crlf ~cr swap strcpy ; \ add a <cr><lf> pair message[ rt0 <html>] message[ rt1 </html>] : startString ( addr -- ) ( load the header text into string ) rt0 swap strcpy ; : endString ( addr -- ) rt1 swap strcpy ; ( ending text ) ( *************************** Number <--> String ************************* ) : f>str ( f addr -- ) \ convert a float to a string in addr depth 4 > IF \ original CH, modified by RTK theAddr ! zeroStr \ dest address @pen 2>r 10 +md @ >r 30000 10 +md ! \ move pen offscreen 3000 3000 !pen f. \ print float: string is at here r> 10 +md ! 2r> !pen \ return pen to origonal position here count count>str \ put it addr ELSE serror THEN ; create b#! 80 allot \ buffer for string conversion : str>f ( addr -- f ) \ convert a string into a float dup >r b#! r> length 1+ cmove \ move to buffer b#! 1- >abs fnumber ; \ and convert ( ********************** User level words ************************* ) : @Direct ( addr new|append -- ) \ get the direct argument swap theAddr ! \ store the string address NEW = IF zeroStr THEN \ clear the string ,s ---- ?data IF theAddr @ $+ THEN \ get the argument ; : @Addr ( addr new|append -- ) \ get the IP address swap theAddr ! \ store the string address NEW = IF zeroStr THEN \ clear the string ,s addr ?data IF theAddr @ $+ THEN \ get it ; : @Browser ( addr new|append -- ) \ get the browser type swap theAddr ! \ store string address NEW = IF zeroStr THEN ,s Agnt ?data IF theAddr @ $+ THEN \ get it ; variable $fld \ holds field name variable $adr \ holds address variable $out \ holds output string message[ & &] \ end of field data marker : @Field ( addr1 addr2 new|append -- ) \ get the data for a field NEW = IF swap dup $CLEAR swap THEN $fld ! \ address of field name string 61 $fld @ $CHAR \ add an "=" $out ! \ address of output string ,s post ?data IF \ there is post data $adr ! $adr @ $fld @ $FIND dup 0= IF drop \ no field data 0 $out @ c! \ empty string ELSE 1- $fld @ length + $adr @ + \ found the field dup & $FIND dup 0= IF drop dup length \ end of string ELSE 1- THEN \ not end of string $out @ $copy+ \ put it in the string THEN THEN 0 $fld @ dup length 1- + c! \ remove "=" ; \ on to field.4th \ Field record: \ \ +----+--------+-----------+---------------+ \ |type| name | value ... | text ........ | \ +----+--------+-----------+---------------+ \ \ where: \ \ type (1 byte) = 0 STR, 1 INT, 5 FP \ name (30 bytes) = null terminated text of field name \ value (0,2,10 bytes) = value of field, for STR is same as start of text, \ 2 bytes for INT, 10 bytes for FP \ text (varies) = text string of value, i.e. INT is 2 then text is "2" \ \ \ Object: \ \ Identical to field record but not entered in field array. \ \ *** None of these words check for overflow or error conditions! Memory is \ at a premium, so you, the programmer, are on your own! \ Misc support words : notvalid? ( c -- t|f ) \ true if c not a valid number character dup 45 = IF drop 0 exit THEN \ is it '-'? dup 46 = IF drop 0 exit THEN \ '.' dup 43 = IF drop 0 exit THEN \ '+' dup 69 = IF drop 0 exit THEN \ 'E' dup 101 = IF drop 0 exit THEN \ 'e' dup 47 > swap 58 < and IF 0 exit THEN \ '0' through '9' -1 \ something else ; : ok? ( s -- s t|f ) \ true if string a valid number dup c@ 0= IF 0 ELSE \ not null dup dup dup length + swap DO r c@ notvalid? IF 0 10000 ELSE 1 THEN +LOOP dup 0= IF ( 0 ) ELSE -1 THEN THEN ; variable #digits \ holds number of significant digits 6 #digits ! \ default to 6 digits : f< ( f1 f2 -- f1<f2 ) fcompare >r fdrop fdrop r> -1 = ; : f> ( f1 f2 -- f1>f2 ) fcompare >r fdrop fdrop r> 1 = ; : pp ( f -- f ) \ set the output number format fdup fabs fdup 0.009 f> >r 100000.0 f< r> and IF #digits @ fix ELSE #digits @ sci THEN ; \ Data types 0 constant STR \ string 1 constant INT \ integer 5 constant FP \ floating point \ Record access : .type ( r -- t ) c@ ; \ return data type : .name ( r -- a ) 1+ ; \ return address of field name : .val ( r -- a ) 31 + ; \ return *address* of value : @val ( r -- v ) \ return *value* of field, addr if STR dup >r .val r> c@ dup STR = IF drop ELSE \ STR dup INT = IF drop @ ELSE \ INT dup FP = IF drop f@ ELSE \ FP drop drop 0 THEN THEN THEN \ error ; : $%int ( r+31 -- ) \ take int value and put in text area as a string dup 2+ >r @ 0 d>f 0 fix r> f>str ; : $%fp ( r+31 -- ) \ take fp value and put in text area as a string dup 10 + >r f@ pp r> f>str ; : !val ( v r -- ) \ put the value, by type, in the record dup >r .val r> c@ dup STR = IF drop dup 0 swap c! strcpy ELSE \ STR, copy string dup INT = IF drop dup >r ! r> $%int ELSE \ INT dup FP = IF drop dup >r f! r> $%fp ELSE \ FP drop drop THEN THEN THEN \ error ; : .text ( r -- a ) \ return the *address* of the field text dup c@ dup STR = IF drop 31 + ELSE \ STR dup INT = IF drop 33 + ELSE \ INT dup FP = IF drop 41 + ELSE \ FP drop drop 0 THEN THEN THEN \ error ; \ Template and Field array words create (T) 50 2* allot \ template array create (F) 50 2* allot \ field array variable #T# 0 #T# ! \ template array index variable #F# 0 #F# ! \ field array index : >table ( r_addr -- ) \ enter record in the table #T# @ 2* (T) + ! #T# @ 1+ #T# ! ; : >field ( r_addr -- ) \ enter record in the field array #F# @ 2* (F) + ! #F# @ 1+ #F# ! ; : @(T) ( idx -- addr ) 2* (T) + @ ; : @(F) ( idx -- addr ) 2* (F) + @ ; \ Define a field record 30 $variable @#$ : " ( string -- ) \ assign text to a string from the input stream. @#$ 34 word here >null here swap $copy ; : #FIELD \ define a field record CREATE here >r swap dup >r 2* + 31 + allot ( compiling: type text-size -- addr ) r> ( type) r> ( addr) 2dup c! ( set type ) swap drop dup >r 1+ @#$ swap strcpy ( set name) r >table ( enter in template array) r> >field ; ( enter in fields array) ( runtime: -- addr ) \ \ E.g. A floating point field 15 characters long named HEIGHT is defined as: \ \ FP 15 " height" #FIELD height \ : #OBJECT \ define an object CREATE here >r swap dup >r 2* + 31 + allot ( compiling: type text-size -- addr ) r> ( type) r> ( addr) 2dup c! ( set type ) swap drop dup >r 1+ @#$ swap strcpy ( set name) r> >table ; ( enter in template array) ( runtime: -- addr ) \ \ E.g. A floating point object 15 characters long named WIDTH is defined as: \ \ FP 15 " width" #OBJECT width \ \ Initialize the fields : <<int ( idx -- ) \ put the integer string in the integer part @(F) dup 33 + ok? IF str>f f>d drop ELSE 0 THEN swap 31 + ! ; : <<fp ( idx -- ) \ put the float string in the float part @(F) dup >r 41 + ok? IF str>f ELSE 0.0 THEN r> 31 + f! ; : <getFields> ( -- ) \ get the fields from the Apple Event and initialize #F# @ 0 DO \ for each field r @(F) 1+ \ get the name r @(F) .text swap NEW \ and the target @Field \ fill in the initial string value r @(F) c@ \ get the type dup 0= IF drop ELSE \ STR, nothing to do dup 1 = IF drop r <<int ELSE \ INT, get integer from string dup 5 = IF drop r <<fp ELSE \ FP, get float from string drop THEN THEN THEN LOOP \ move to the next field ; \ on to template.4th... \ This code handles the reading and evaluation of the template HTML file. \ \ A template file is an external text file that contains the HTML source to \ be returned by the CGI with named markers where calculated values are to \ be substituted: \ \ <h1>A Reply</h1><hr> \ You are: `name` <p> \ Age: `age` <p> \ Weight: `weight` <p> \ \ The above will look for fields or named strings with the names "name", "age", \ and "weight" and substitute their value in the reply string. \ *** None of these words check for overflow or error conditions! Memory is \ at a premium, so you, the programmer, are on your own! 1024 constant buffSize \ size of input buffer create rwbuff buffSize allot \ the buffer variable ~i \ start by filling the buffer variable ~f \ number of bytes into the file : fillbuff ( -- ) \ call this after OPEN to use the buffer 1024 ~i ! 0 ~f ! rwbuff buffSize 0 fill ; : getch ( -- c ) \ read a character from the buffer ~i @ dup 1024 < IF rwbuff + c@ 1 ~i +! 1 ~f +! ELSE drop 0 ~i ! \ clear index rwbuff buffSize 0 fill @size ~f @ - 3 - dup 1 < IF drop -1 \ nothing to read, return -1 ELSE buffSize min \ # bytes to read rwbuff swap READ rwbuff c@ 1 ~i +! THEN THEN ; ( string array words ) : array>> ( #elements -- ) \ create an array of #elements create 2* allot ; : !array ( data index array -- ) \ store in index swap 2* + ! ; : @array ( index array -- data ) \ get data in an array swap 2* + @ ; : >array ( 00 01 .. n array -- ) \ store entire array swap -1 swap 1- DO dup rot swap r swap !array -1 +LOOP ; \ add these to the number convert : n>str ( n s -- ) \ integer to string >r 0 d>f r> 0 fix f>str ; : str>num ( s -- n ) \ string to integer str>f f>d drop ; variable ~output \ output string variable ~fname \ filename string variable ~length \ hold length of output string create !@# 32 allot \ hold the name create #@! 0 , 0 , \ null string : >!@# ( c -- ) \ append a character to !@# !@# length !@# + dup >r c! \ character 0 r> 1+ c! ; \ null : token ( -- ) \ load !@# with name of token 0 !@# c! \ clear !@# BEGIN getch dup 96 = 0= \ while not ` (backquote) WHILE >!@# REPEAT \ append to !@# drop ; : lookup ( -- addr ) \ lookup the token name and return address of text part #T# @ 0 DO r @(T) .name !@# $= IF r @(T) .text \ got it 10000 ELSE 1 THEN +LOOP ; : >>output ( c -- ) \ append a character ~output @ ~length @ + dup >r c! 0 r> 1+ c! 1 ~length +! ; macro : template ( output fname new|append -- ) \ process a template file >r ~fname ! ~output ! r> IF 0 ~output @ c! 0 ~length ! \ zero the string ELSE ~output @ length ~length ! THEN \ append to string ~fname @ open \ open the file fillbuff \ init input buffer @size 0 DO getch \ get a character dup 96 = IF \ check for ` (backquote) drop \ lose the ` token \ get the name lookup \ and lookup the string ~output @ strcpy \ and put it in ~output @ length ~length ! \ adjust length !@# length 1+ \ length of name+1 (for backquote) ELSE dup 31 > IF >>output \ append to output ELSE drop THEN 1 THEN +LOOP close \ close the file ; \ that's all folks!